home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tcl7.4 / tclMain.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-06-08  |  7.5 KB  |  293 lines
  1. /* 
  2.  * main.c --
  3.  *
  4.  *    Main program for Tcl shells and other Tcl-based applications.
  5.  *
  6.  * Copyright (c) 1988-1994 The Regents of the University of California.
  7.  * Copyright (c) 1994 Sun Microsystems, Inc.
  8.  *
  9.  * See the file "license.terms" for information on usage and redistribution
  10.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11.  */
  12.  
  13. #ifndef lint
  14. static char sccsid[] = "@(#) tclMain.c 1.21 95/06/08 10:55:55";
  15. #endif
  16.  
  17. #include <stdio.h>
  18. #include <tcl.h>
  19. #include <errno.h>
  20. #ifdef NO_STDLIB_H
  21. #   include "compat/stdlib.h"
  22. #else
  23. #   include <stdlib.h>
  24. #endif
  25.  
  26. /*
  27.  * Declarations for various library procedures and variables (don't want
  28.  * to include tclPort.h here, because people might copy this file out of
  29.  * the Tcl source directory to make their own modified versions).
  30.  * Note:  "exit" should really be declared here, but there's no way to
  31.  * declare it without causing conflicts with other definitions elsewher
  32.  * on some systems, so it's better just to leave it out.
  33.  */
  34.  
  35. extern int        errno;
  36. extern int        isatty _ANSI_ARGS_((int fd));
  37. extern char *        strcpy _ANSI_ARGS_((char *dst, CONST char *src));
  38.  
  39. static Tcl_Interp *interp;    /* Interpreter for application. */
  40. static Tcl_DString command;    /* Used to buffer incomplete commands being
  41.                  * read from stdin. */
  42. #ifdef TCL_MEM_DEBUG
  43. static char dumpFile[100];    /* Records where to dump memory allocation
  44.                  * information. */
  45. static int quitFlag = 0;    /* 1 means the "checkmem" command was
  46.                  * invoked, so the application should quit
  47.                  * and dump memory allocation information. */
  48. #endif
  49.  
  50. /*
  51.  * Forward references for procedures defined later in this file:
  52.  */
  53.  
  54. #ifdef TCL_MEM_DEBUG
  55. static int        CheckmemCmd _ANSI_ARGS_((ClientData clientData,
  56.                 Tcl_Interp *interp, int argc, char *argv[]));
  57. #endif
  58.  
  59. /*
  60.  *----------------------------------------------------------------------
  61.  *
  62.  * Tcl_Main --
  63.  *
  64.  *    Main program for tclsh and most other Tcl-based applications.
  65.  *
  66.  * Results:
  67.  *    None. This procedure never returns (it exits the process when
  68.  *    it's done.
  69.  *
  70.  * Side effects:
  71.  *    This procedure initializes the Tk world and then starts
  72.  *    interpreting commands;  almost anything could happen, depending
  73.  *    on the script being interpreted.
  74.  *
  75.  *----------------------------------------------------------------------
  76.  */
  77.  
  78. void
  79. Tcl_Main(argc, argv, appInitProc)
  80.     int argc;                /* Number of arguments. */
  81.     char **argv;            /* Array of argument strings. */
  82.     Tcl_AppInitProc *appInitProc;    /* Application-specific initialization
  83.                      * procedure to call after most
  84.                      * initialization but before starting
  85.                      * to execute commands. */
  86. {
  87.     char buffer[1000], *cmd, *args, *fileName;
  88.     int code, gotPartial, tty;
  89.     int exitCode = 0;
  90.  
  91.     interp = Tcl_CreateInterp();
  92. #ifdef TCL_MEM_DEBUG
  93.     Tcl_InitMemory(interp);
  94.     Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
  95.         (Tcl_CmdDeleteProc *) NULL);
  96. #endif
  97.  
  98.     /*
  99.      * Make command-line arguments available in the Tcl variables "argc"
  100.      * and "argv".  If the first argument doesn't start with a "-" then
  101.      * strip it off and use it as the name of a script file to process.
  102.      */
  103.  
  104.     fileName = NULL;
  105.     if ((argc > 1) && (argv[1][0] != '-')) {
  106.     fileName = argv[1];
  107.     argc--;
  108.     argv++;
  109.     }
  110.     args = Tcl_Merge(argc-1, argv+1);
  111.     Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
  112.     ckfree(args);
  113.     sprintf(buffer, "%d", argc-1);
  114.     Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
  115.     Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
  116.         TCL_GLOBAL_ONLY);
  117.  
  118.     /*
  119.      * Set the "tcl_interactive" variable.
  120.      */
  121.  
  122.     tty = isatty(0);
  123.     Tcl_SetVar(interp, "tcl_interactive",
  124.         ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
  125.  
  126.     /*
  127.      * Invoke application-specific initialization.
  128.      */
  129.  
  130.     if ((*appInitProc)(interp) != TCL_OK) {
  131.     fprintf(stderr, "application-specific initialization failed: %s\n",
  132.         interp->result);
  133.     }
  134.  
  135.     /*
  136.      * If a script file was specified then just source that file
  137.      * and quit.
  138.      */
  139.  
  140.     if (fileName != NULL) {
  141.     code = Tcl_EvalFile(interp, fileName);
  142.     if (code != TCL_OK) {
  143.         fprintf(stderr, "%s\n", interp->result);
  144.         exitCode = 1;
  145.     }
  146.     goto done;
  147.     }
  148.  
  149.     /*
  150.      * We're running interactively.  Source a user-specific startup
  151.      * file if the application specified one and if the file exists.
  152.      */
  153.  
  154.     if (tcl_RcFileName != NULL) {
  155.     Tcl_DString buffer;
  156.     char *fullName;
  157.     FILE *f;
  158.  
  159.     fullName = Tcl_TildeSubst(interp, tcl_RcFileName, &buffer);
  160.     if (fullName == NULL) {
  161.         fprintf(stderr, "%s\n", interp->result);
  162.     } else {
  163.         f = fopen(fullName, "r");
  164.         if (f != NULL) {
  165.         code = Tcl_EvalFile(interp, fullName);
  166.         if (code != TCL_OK) {
  167.             fprintf(stderr, "%s\n", interp->result);
  168.         }
  169.         fclose(f);
  170.         }
  171.     }
  172.     Tcl_DStringFree(&buffer);
  173.     }
  174.  
  175.     /*
  176.      * Process commands from stdin until there's an end-of-file.
  177.      */
  178.  
  179.     gotPartial = 0;
  180.     Tcl_DStringInit(&command);
  181.     while (1) {
  182.     clearerr(stdin);
  183.     if (tty) {
  184.         char *promptCmd;
  185.  
  186.         promptCmd = Tcl_GetVar(interp,
  187.         gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
  188.         if (promptCmd == NULL) {
  189.         defaultPrompt:
  190.         if (!gotPartial) {
  191.             fputs("% ", stdout);
  192.         }
  193.         } else {
  194.         code = Tcl_Eval(interp, promptCmd);
  195.         if (code != TCL_OK) {
  196.             fprintf(stderr, "%s\n", interp->result);
  197.             Tcl_AddErrorInfo(interp,
  198.                 "\n    (script that generates prompt)");
  199.             goto defaultPrompt;
  200.         }
  201.         }
  202.         fflush(stdout);
  203.     }
  204.     if (fgets(buffer, 1000, stdin) == NULL) {
  205.         if (ferror(stdin)) {
  206.         if (errno == EINTR) {
  207.             if (tcl_AsyncReady) {
  208.             (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
  209.             }
  210.             clearerr(stdin);
  211.         } else {
  212.             goto done;
  213.         }
  214.         } else {
  215.         if (!gotPartial) {
  216.             goto done;
  217.         }
  218.         }
  219.         buffer[0] = 0;
  220.     }
  221.     cmd = Tcl_DStringAppend(&command, buffer, -1);
  222.     if ((buffer[0] != 0) && !Tcl_CommandComplete(cmd)) {
  223.         gotPartial = 1;
  224.         continue;
  225.     }
  226.  
  227.     gotPartial = 0;
  228.     code = Tcl_RecordAndEval(interp, cmd, 0);
  229.     Tcl_DStringFree(&command);
  230.     if (code != TCL_OK) {
  231.         fprintf(stderr, "%s\n", interp->result);
  232.     } else if (tty && (*interp->result != 0)) {
  233.         printf("%s\n", interp->result);
  234.     }
  235. #ifdef TCL_MEM_DEBUG
  236.     if (quitFlag) {
  237.         Tcl_DeleteInterp(interp);
  238.         Tcl_DumpActiveMemory(dumpFile);
  239.         exit(0);
  240.     }
  241. #endif
  242.     }
  243.  
  244.     /*
  245.      * Rather than calling exit, invoke the "exit" command so that
  246.      * users can replace "exit" with some other command to do additional
  247.      * cleanup on exit.  The Tcl_Eval call should never return.
  248.      */
  249.  
  250.     done:
  251.     sprintf(buffer, "exit %d", exitCode);
  252.     Tcl_Eval(interp, buffer);
  253. }
  254.  
  255. /*
  256.  *----------------------------------------------------------------------
  257.  *
  258.  * CheckmemCmd --
  259.  *
  260.  *    This is the command procedure for the "checkmem" command, which
  261.  *    causes the application to exit after printing information about
  262.  *    memory usage to the file passed to this command as its first
  263.  *    argument.
  264.  *
  265.  * Results:
  266.  *    Returns a standard Tcl completion code.
  267.  *
  268.  * Side effects:
  269.  *    None.
  270.  *
  271.  *----------------------------------------------------------------------
  272.  */
  273. #ifdef TCL_MEM_DEBUG
  274.  
  275.     /* ARGSUSED */
  276. static int
  277. CheckmemCmd(clientData, interp, argc, argv)
  278.     ClientData clientData;        /* Not used. */
  279.     Tcl_Interp *interp;            /* Interpreter for evaluation. */
  280.     int argc;                /* Number of arguments. */
  281.     char *argv[];            /* String values of arguments. */
  282. {
  283.     if (argc != 2) {
  284.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  285.         " fileName\"", (char *) NULL);
  286.     return TCL_ERROR;
  287.     }
  288.     strcpy(dumpFile, argv[1]);
  289.     quitFlag = 1;
  290.     return TCL_OK;
  291. }
  292. #endif
  293.